home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PASWIZ20
/
ARCHIVES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-11-04
|
16KB
|
545 lines
{ +----------------------------------------------------------------------+
| |
| PasWiz Copyright (c) 1990-1994 Thomas G. Hanlin III |
| |
+----------------------------------------------------------------------+
Archives:
This collection of routines allows you to retrieve full directory
information from any popular archive format: ARC, ARJ, LZH, PAK, ZIP,
ZOO, or even self-extracting .EXEs.
}
UNIT Archives;
INTERFACE
PROCEDURE CloseA;
FUNCTION GetCRCA: STRING;
FUNCTION GetDateA: STRING;
FUNCTION GetNameA: STRING;
PROCEDURE GetSizeA (VAR OriginalSize: LONGINT; VAR CurrentSize: LONGINT);
FUNCTION GetStoreA: STRING;
FUNCTION GetTimeA: STRING;
PROCEDURE FindNextA (VAR ErrCode: INTEGER);
PROCEDURE FindFirstA (Archive, FileName: STRING; VAR ErrCode: INTEGER);
{ --------------------------------------------------------------------------- }
IMPLEMENTATION
USES
Strings;
TYPE
BufferType = RECORD
CASE banana: BOOLEAN OF
FALSE: (junk: CHAR; buf: ARRAY[1..127] OF CHAR);
TRUE : (str: STRING[128]);
END;
VAR
ArcType:
INTEGER;
Handle:
FILE;
PatternFileName:
STRING;
Header:
BufferType;
FUNCTION StrF (x: WORD): STRING;
VAR
st: STRING;
BEGIN
Str(x, st);
StrF := st;
END;
FUNCTION CVI (st: STRING): INTEGER;
BEGIN
CVI := ORD(st[2]) SHL 8 + ORD(St[1]);
END;
FUNCTION CVL (st: STRING): LONGINT;
BEGIN
CVL := (ORD(st[4]) SHL 8 + ORD(St[3]) SHL 16)
+ ORD(st[2]) SHL 8 + ORD(St[1]);
END;
PROCEDURE CloseA;
BEGIN
Close(Handle);
END;
FUNCTION FileExists(FileName: STRING): BOOLEAN;
VAR
Handle: FILE;
BEGIN
{$I-}
Assign(Handle, FileName);
Reset(Handle);
Close(Handle);
{$I+}
FileExists := (IOResult = 0);
END;
FUNCTION GetCRCA: STRING;
VAR
CRC, Result: STRING;
tmp, Digit: WORD;
BEGIN
CASE ArcType OF
1: CRC := Copy(Header.str, 24, 2) + CHR(0) + CHR(0);
2: CRC := Copy(Header.str, ORD(Header.str[22]) + 23, 2) + CHR(0) + CHR(0);
3: CRC := Copy(Header.str, 15, 4);
4: CRC := Copy(Header.str, 19, 2) + CHR(0) + CHR(0);
5: CRC := Copy(Header.str, 25, 4);
END;
CRC := CRC[4] + CRC[3] + CRC[2] + CRC[1];
Result := '';
FOR tmp := 1 TO 4 DO BEGIN
Digit := ORD(CRC[tmp]) SHR 4;
IF Digit < 10 THEN
Result := Result + CHR(Digit + 48)
ELSE
Result := Result + CHR(Digit + 55);
Digit := ORD(CRC[tmp]) AND $F;
IF Digit < 10 THEN
Result := Result + CHR(Digit + 48)
ELSE
Result := Result + CHR(Digit + 55);
END;
GetCRCA := Result;
END;
FUNCTION GetDateA: STRING;
VAR
Year, Month, Day: STRING;
tmp: LONGINT;
BEGIN
CASE ArcType OF
1: tmp := CVL(Copy(Header.str, 20, 2) + CHR(0) + CHR(0));
2: tmp := CVL(Copy(Header.str, 18, 2) + CHR(0) + CHR(0));
3: tmp := CVL(Copy(Header.str, 13, 2) + CHR(0) + CHR(0));
4: tmp := CVL(Copy(Header.str, 15, 2) + CHR(0) + CHR(0));
5: tmp := CVL(Copy(Header.str, 15, 2) + CHR(0) + CHR(0));
END;
Year := Right('000' + StrF(tmp DIV 512 + 1980), 4);
Day := Right('0' + StrF(tmp AND $1F), 2);
Month := Right('0' + StrF(tmp DIV 32 AND $F), 2);
GetDateA := Month + '-' + Day + '-' + Year;
END;
FUNCTION GetNameA: STRING;
VAR
FileName, St: STRING;
FLen: WORD;
BEGIN
CASE ArcType OF
1: BEGIN
St := Copy(Header.str, 3, 13);
FLen := Pos(CHR(0), St);
IF FLen = 0 THEN
FLen := 12
ELSE
DEC(FLen);
FileName := St;
END;
2: BEGIN
FLen := ORD(Header.str[22]);
FileName := Copy(Header.str, 23, FLen);
END;
3: BEGIN
FLen := ORD(Header.str[27]);
FileName := Copy(Header.str, 31, FLen);
END;
4: IF Header.str[31] = CHR(1) THEN
FLen := 0
ELSE BEGIN
FLen := Pos(CHR(0), Copy(Header.str, 39, 13)) - 1;
FileName := Copy(Header.str, 39, FLen);
END;
5: IF ORD(Header.str[11]) > 1 THEN
FLen := 0
ELSE BEGIN
St := Copy(Header.str, 35, 80);
Flen := Pos(CHR(0), St);
IF FLen > 0 THEN DEC(FLen);
FileName := St;
END;
END;
GetNameA := Copy(FileName, 1, FLen);
END;
PROCEDURE GetSizeA (VAR OriginalSize: LONGINT; VAR CurrentSize: LONGINT);
BEGIN
CASE ArcType OF
1: BEGIN
CurrentSize := CVL(Copy(Header.str, 16, 4));
IF ORD(Header.str[2]) = 1 THEN
OriginalSize := CurrentSize
ELSE
OriginalSize := CVL(Copy(Header.str, 26, 4));
END;
2: BEGIN
OriginalSize := CVL(Copy(Header.str, 12, 4));
CurrentSize := CVL(Copy(Header.str, 8, 4));
END;
3: BEGIN
OriginalSize := CVL(Copy(Header.str, 23, 4));
CurrentSize := CVL(Copy(Header.str, 19, 4));
END;
4: BEGIN
OriginalSize := CVL(Copy(Header.str, 21, 4));
CurrentSize := CVL(Copy(Header.str, 25, 4));
END;
5: BEGIN
OriginalSize := CVL(Copy(Header.str, 21, 4));
CurrentSize := CVL(Copy(Header.str, 17, 4));
END;
END;
END;
FUNCTION GetStoreA: STRING;
BEGIN
CASE ArcType OF
1: CASE ORD(Header.str[2]) OF
1, 2: GetStoreA := 'Stored';
3: GetStoreA := 'Packed';
4: GetStoreA := 'Squeezed';
5, 6: GetStoreA := 'crunched';
7, 8: GetStoreA := 'Crunched';
9: GetStoreA := 'Squashed';
10: GetStoreA := 'Crushed';
11: GetStoreA := 'Distill';
ELSE GetStoreA := '';
END;
2: GetStoreA := RTrim(Copy(Header.str, 3, 5));
3: CASE ORD(Header.str[9]) OF
0: GetStoreA := 'Stored';
1: GetStoreA := 'Shrunk';
2: GetStoreA := 'Reduce-1';
3: GetStoreA := 'Reduce-2';
4: GetStoreA := 'Reduce-3';
5: GetStoreA := 'Reduce-4';
6: GetStoreA := 'Imploded';
8: GetStoreA := 'Deflated';
ELSE GetStoreA := '';
END;
4: GetStoreA := '';
5: GetStoreA := CHR(ORD(Header.str[10]) + 48);
END;
END;
FUNCTION GetTimeA: STRING;
VAR
tmp: LONGINT;
Hour, Second, Minute: STRING;
BEGIN
CASE ArcType OF
1: tmp := CVL(Copy(Header.str, 22, 2) + CHR(0) + CHR(0));
2: tmp := CVL(Copy(Header.str, 16, 2) + CHR(0) + CHR(0));
3: tmp := CVL(Copy(Header.str, 11, 2) + CHR(0) + CHR(0));
4: tmp := CVL(Copy(Header.str, 17, 2) + CHR(0) + CHR(0));
5: tmp := CVL(Copy(Header.str, 13, 2) + CHR(0) + CHR(0));
END;
Hour := Right('0' + StrF(tmp DIV 2048), 2);
Second := Right('0' + StrF((tmp AND $1F) * 2), 2);
Minute := Right('0' + StrF((tmp DIV 32) AND $3F), 2);
GetTimeA := Hour + ':' + Minute + ':' + Second;
END;
PROCEDURE FindNextA (VAR ErrCode: INTEGER);
VAR
CurFileName: STRING;
Found: BOOLEAN;
Chars, Posn: WORD;
BEGIN
Found := FALSE;
WHILE NOT Found AND (ErrCode = 0) DO BEGIN
Posn := FilePos(Handle);
CASE ArcType OF
1: BEGIN
IF ORD(Header.str[2]) = 1 THEN
INC(Posn, 25)
ELSE
INC(Posn, 29);
INC(Posn, CVL(Copy(Header.str, 16, 4)));
END;
2: INC(Posn, LONGINT(ORD(Header.str[1])) + 2
+ CVL(Copy(Header.str, 8, 4)));
3: INC(Posn, 30 + LONGINT(CVI(Copy(Header.str, 27, 2)))
+ LONGINT(CVI(Copy(Header.str, 29, 2)))
+ CVL(Copy(Header.str, 19, 4)));
4: Posn := CVL(Copy(Header.str, 7, 4));
5: INC(Posn, LONGINT(CVI(Copy(Header.str, 3, 2)))
+ CVL(Copy(Header.str, 17, 4)) + 10);
END;
IF ErrCode = 0 THEN BEGIN
Seek(Handle, Posn);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.buf, 128, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
CASE ArcType OF
1: IF (ORD(Header.str[1]) <> 26) OR (ORD(Header.str[2]) = 0) THEN
ErrCode := 9999;
2: IF (Header.str[3] <> '-') OR (ORD(Header.str[1]) = 0) THEN
ErrCode := 9999;
3: IF Copy(Header.str, 1, 4) <> 'PK' + CHR(3) + CHR(4) THEN
ErrCode := 9999;
5: IF (Copy(Header.str, 1, 2) <> CHR($60) + CHR($EA)) OR (CVI(Copy(Header.str, 3, 2)) = 0) THEN
ErrCode := 9999;
ELSE ;
END;
IF ErrCode = 0 THEN BEGIN
Seek(Handle, Posn);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
CurFileName := GetNameA;
IF Length(CurFileName) > 0 THEN
Found := MatchFile(PatternFileName, CurFileName)
ELSE
Found := FALSE;
END;
END;
END;
PROCEDURE FindFirstA (Archive, FileName: STRING; VAR ErrCode: INTEGER);
VAR
CurFileName, St: STRING;
Posn: LONGINT;
Found: BOOLEAN;
Chars: WORD;
BEGIN
ErrCode := 0;
Archive := UpperCase(Archive);
PatternFileName := UpperCase(FileName);
IF Pos('.', Archive) = 0 THEN
IF FileExists(Archive + '.ZIP') THEN
Archive := Archive + '.ZIP'
ELSE IF FileExists(Archive + '.LZH') THEN
Archive := Archive + '.LZH'
ELSE IF FileExists(Archive + '.ARC') THEN
Archive := Archive + '.ARC'
ELSE IF FileExists(Archive + '.PAK') THEN
Archive := Archive + '.PAK'
ELSE IF FileExists(Archive + '.ZOO') THEN
Archive := Archive + '.ZOO'
ELSE IF FileExists(Archive + '.ARJ') THEN
Archive := Archive + '.ARJ'
ELSE IF FileExists(Archive + '.EXE') THEN
Archive := Archive + '.EXE'
ELSE IF FileExists(Archive + '.COM') THEN
Archive := Archive + '.COM'
ELSE
Archive := Archive + '.';
St := Right(Archive, 3);
IF (St = 'ARC') OR (St = 'PAK') THEN
ArcType := 1
ELSE IF St = 'LZH' THEN
ArcType := 2
ELSE IF St = 'ZIP' THEN
ArcType := 3
ELSE IF St = 'ZOO' THEN
ArcType := 4
ELSE IF St = 'ARJ' THEN
ArcType := 5
ELSE IF (St = 'COM') OR (St = 'EXE') THEN
ArcType := -1
ELSE
ErrCode := 9999;
Posn := 0;
IF ErrCode = 0 THEN BEGIN
Assign(Handle, Archive);
Reset(Handle, 1);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
IF ArcType = -1 THEN BEGIN
BlockRead(Handle, Header.buf, 2, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
IF ErrCode = 0 THEN
IF Header.str <> 'MZ' THEN
ErrCode := 9999;
IF ErrCode = 0 THEN BEGIN
Seek(Handle, 1636);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.buf, 8, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
IF Copy(Header.str, 3, 3) = '-lh' THEN BEGIN
ArcType := 2;
Posn := 1636;
Seek(Handle, Posn);
ErrCode := IOResult;
END;
END;
IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN { check for new ZIP }
Seek(Handle, 15770);
ErrCode := IOResult;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.buf, 4, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
IF Copy(Header.str, 1, 4) = 'PK' + CHR(3) + CHR(4) THEN BEGIN
ArcType := 3;
Posn := 15770;
Seek(Handle, Posn);
ErrCode := IOResult;
END
ELSE
ErrCode := 9999;
END;
END;
IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN { check for old ZIP }
Seek(Handle, 12784);
ErrCode := IOResult;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.buf, 4, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
IF Copy(Header.str, 1, 4) = 'PK' + CHR(3) + CHR(4) THEN BEGIN
ArcType := 3;
Posn := 12784;
Seek(Handle, Posn);
ErrCode := IOResult;
END
ELSE
ErrCode := 9999;
END;
END;
IF (ErrCode = 0) AND (ArcType = -1) THEN BEGIN { check for ARJ }
Seek(Handle, 14858);
BlockRead(Handle, Header.str, 2, Chars);
Header.str[0] := CHR(Chars);
IF Header.str = CHR($60) + CHR($EA) THEN BEGIN
ArcType := 5;
Posn := 14858;
Seek(Handle, Posn);
END;
END;
IF (ErrCode = 0) AND (ArcType = -1) THEN
ErrCode := 9999;
END;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.buf, 128, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
CASE ArcType OF
1: IF (ORD(Header.str[1]) <> 26) OR (ORD(Header.str[2]) = 0) THEN
ErrCode := 9999;
2: IF Header.str[3] <> '-' THEN
ErrCode := 9999;
3: IF Copy(Header.str, 1, 4) <> 'PK' + CHR(3) + CHR(4) THEN
ErrCode := 9999;
4: IF Copy(Header.str, 21, 4) = CHR($DC) + CHR($A7) + CHR($C4) + CHR($FD) THEN BEGIN
Posn := CVL(Copy(Header.str, $19, 4));
Seek(Handle, Posn);
ErrCode := IOResult;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.str, 128, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
END
ELSE
ErrCode := 9999;
5: IF Copy(Header.str, 1, 2) <> CHR($60) + CHR($EA) THEN
ErrCode := 9999
ELSE BEGIN
Posn := LONGINT(CVI(Copy(Header.str, 3, 2))) + 10;
Seek(Handle, Posn);
ErrCode := IOResult;
IF ErrCode = 0 THEN BEGIN
BlockRead(Handle, Header.buf, 128, Chars);
Header.str[0] := CHR(Chars);
ErrCode := IOResult;
END;
END;
END;
IF ErrCode = 0 THEN BEGIN
Seek(Handle, Posn);
ErrCode := IOResult;
END;
IF ErrCode = 0 THEN BEGIN
CurFileName := GetNameA;
IF Length(CurFileName) > 0 THEN
Found := MatchFile(PatternFileName, CurFileName)
ELSE
Found := FALSE;
END;
IF (ErrCode <> 0) OR NOT Found THEN
FindNextA(ErrCode);
END;
END;
{ ----------------------- initialization code --------------------------- }
BEGIN
END.